home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.0-b / stk-3 / blt-for-STk-3.0 / Demos / busy.stk < prev    next >
Encoding:
Text File  |  1995-12-26  |  4.2 KB  |  151 lines
  1. ;;;;
  2. ;;;; Script to test the "busy" command.
  3. ;;;; 
  4. (set! *load-path* (cons ".." *load-path*))
  5. (require "blt")
  6.  
  7. ;;;;
  8. ;;;; General widget class resource attributes
  9. ;;;;
  10. (option 'add "*Button.padX"     10)
  11. (option 'add "*Button.padY"     2)
  12. (option 'add "*Scale.relief"     'sunken)
  13. (option 'add "*Scale.orient"    'horizontal)
  14. (option 'add "*Entry.relief"     'sunken)
  15.  
  16.  
  17. (define activeBg 'red)
  18. (define normalBg 'springgreen)
  19. (define bitmapFg 'blue)
  20. (define bitmapBg 'green)
  21.  
  22. (let ((visual (winfo 'screenvisual *root*))) 
  23.   (when (or (eq? visual 'staticgray) (eq? visual 'grayscale))
  24.     (set! activeBg black)
  25.     (set! normalBg white)
  26.     (set! bitmapFg black)
  27.     (set! bitmapBg white)))
  28.  
  29. ;;;;
  30. ;;;; Instance specific widget options
  31. ;;;;
  32. (option 'add "STk.top.relief"         'sunken)
  33. (option 'add "STk.top.borderWidth"     4)
  34. (option 'add "STk.top.background"     normalBg)
  35. (option 'add "STk.b1.text"         "Test")
  36. (option 'add "STk.b2.text"         "Quit")
  37. (option 'add "STk.b3.text"         "New button")
  38. (option 'add "STk.b4.text"         "Hold")
  39. (option 'add "STk.b4.background"     activeBg)
  40. (option 'add "STk.b4.foreground"     normalBg)
  41. (option 'add "STk.b5.text"         "Release")
  42. (option 'add "STk.b5.background"     normalBg)
  43. (option 'add "STk.b5.foreground"     activeBg)
  44.  
  45. ;;;;
  46. ;;;; This never gets used; it's reset by the Animate proc. It's 
  47. ;;;; here to just demonstrate how to set busy window options via
  48. ;;;; the host window path name
  49. ;;;;
  50. (option 'add "STk.top.busyCursor"     'bogosity)
  51.  
  52. ;;;;
  53. ;;;; Initialize a list bitmap file names which make up the animated 
  54. ;;;; fish cursor. The bitmap mask files have a "m" appended to them.
  55. ;;;;
  56. (define bitmaps '(fc_left fc_left1 fc_mid fc_right1 fc_right))
  57.  
  58. ;;;;
  59. ;;;; Counter for new buttons created by the "New button" button
  60. ;;;;
  61. (define numWin 0)
  62. ;;;;
  63. ;;;; Current index into the bitmap list. Indicates the current cursor.
  64. ;;;; If -1, indicates to stop animating the cursor.
  65. ;;;;
  66. (define cnt -1)
  67.  
  68. ;;;;
  69. ;;;; Create two frames. The top frame will be the host window for the
  70. ;;;; busy window.  It'll contain widgets to test the effectiveness of
  71. ;;;; the busy window.  The bottom frame will contain buttons to 
  72. ;;;; control the testing.
  73. ;;;;
  74. (frame '.top)
  75. (frame '.bottom)
  76.  
  77. ;;;;
  78. ;;;; Create some widgets to test the busy window and its cursor
  79. ;;;;
  80. (button '.b1 :command (lambda () (display "Not busy.\n")))
  81. (button '.b2 :command (lambda () (destroy *root*)))
  82. (entry '.e1) 
  83. (scale '.s1)
  84.  
  85. ;;;;
  86. ;;;; The following buttons sit in the lower frame to control the demo
  87. ;;;;
  88. (button '.b3 :command (lambda ()
  89.             (set! numWin (+ numWin 1))
  90.             (let* ((name (format #f "button#~A" numWin))
  91.                    (widg (& .top "." name)))
  92.               (button widg
  93.                   :text name
  94.                   :command (lambda ()
  95.                          (format #t "I am ~A\n" name)))
  96.               (pack widg :expand #t :padx 10 :pady 10))))
  97. (button '.b4 :command (lambda ()
  98.             (blt_busy '.top :in *root*)
  99.             (focus "")
  100.             (when (< cnt 0)
  101.               (tk-set! .top :bg activeBg)
  102.               (set! cnt 0)
  103.               (Animate .top))))
  104. (button '.b5 :command (lambda ()
  105.             (catch (blt_busy 'release '.top))
  106.             (set! cnt -1)
  107.             (tk-set! .top :bg normalBg)))
  108.  
  109. ;;;;
  110. ;;;; Notice that the widgets packed in .top and .bottom are not their children
  111. ;;;;
  112. (pack .b1 .e1 .s1 .b2 :in .top    :expand #t :padx 10 :pady 10)
  113. (pack .b3 .b4 .b5     :in .bottom :expand #t :padx 10 :pady 10)
  114.  
  115.  
  116. ;;;;
  117. ;;;; Finally, realize and map the top level window
  118. ;;;;
  119. (pack .top  .bottom :expand #t)
  120.  
  121. ;;;;
  122. ;;;; Simple cursor animation routine: Uses the "after" command to 
  123. ;;;; circulate through a list of cursors every 0.075 seconds. The
  124. ;;;; first pass through the cursor list may appear sluggish because 
  125. ;;;; the bitmaps have to be read from the disk.  Tk's cursor cache
  126. ;;;; takes care of it afterwards.
  127. ;;;;
  128. (define (Animate w)
  129.   (if (>= cnt 0)
  130.       (let* ((name (list-ref bitmaps cnt))
  131.          (src  (format #f "@bitmaps/~A"  name))
  132.          (mask (format #f "bitmaps/~Am" name)))
  133.     (blt_busy 'configure w :cursor (format #f "~A ~A ~A ~A"
  134.                            src mask bitmapFg bitmapBg))
  135.     (set! cnt (modulo (+ cnt 1) 5))
  136.     (after 75 (lambda () (Animate w))))))
  137.  
  138.  
  139.  
  140. ;;;;
  141. ;;;; For testing purposes allow the top level window to be resized 
  142. ;;;;
  143. (wm 'min *root* 0 0)
  144.  
  145. ;;;;
  146. ;;;; If the "raise" window command exists, force the demo to stay raised
  147. ;;;;
  148. (if (symbol-bound? 'raise)
  149.     (bind *root* "<Visibility>" '(raise "%W")))
  150.  
  151.